home *** CD-ROM | disk | FTP | other *** search
/ Enigma Amiga Life 109 / EnigmaAmiga109CD.iso / dalla rivista / amiga.free / sorgenti vari / wolfedit2 2.0.4 source.sit / WolfEdit2 2.0.4 Source / ULZSS.p < prev    next >
Text File  |  1996-04-27  |  13KB  |  527 lines
  1. unit ULZSS;
  2.  
  3. interface
  4.  
  5.     type
  6.  
  7.         BytesPtr = ^BytesArray;
  8.         BytesArray = packed array[0..999999] of 0..255;
  9.  
  10.     function LZSS (src: univ BytesPtr; srcLen: longint): Handle;
  11.     function LZSSX (skip: longint; header: univ BytesPtr; headerLen: longint; data: univ BytesPtr; dataLen: longint; compressing: boolean): Handle;
  12.     procedure DLZSS (src, dst: univ BytesPtr; dstLen: longint);
  13.     procedure DLZSSX (src, dst: univ BytesPtr; skip, dstLen: longint);
  14.     procedure TransposePixels (src, dst: univ longint; width, height: integer);
  15.     procedure UnpackObject (src: univ longint; srcSize: longint; dst: univ longint; dstWidth: integer);
  16.     function PackObject (src: univ BytesPtr; width, height: integer): Handle;
  17.  
  18. implementation
  19.     uses
  20.         UGoof;
  21.  
  22.     const
  23.  
  24.         compressingAlertDlogID = 134;
  25.         compressingAlertStringsID = 130;
  26.         outOfMemAlrtID = 148;
  27.         progressItem = 2;
  28.  
  29.     type
  30.  
  31.         PackedByte = packed array[0..0] of 0..255;
  32.         BytePtr = ^PackedByte;
  33.         WordPtr = ^integer;
  34.  
  35.     var
  36.  
  37.         gAlert: DialogPtr;
  38.         gProgressRect: Rect;
  39.         gProgress, gMaxProgress: integer;
  40.         gOldPort: GrafPtr;
  41.  
  42. {$D+}
  43.     procedure ShowWatch;
  44.     begin
  45.         gCurrentCursor := GetCursor(watchCursor);
  46.         SetCursor(gCurrentCursor^^);
  47.     end;
  48.  
  49. {$D+}
  50.     procedure ShowCompressingAlert (compressing: boolean);
  51.         var
  52.             iType: integer;
  53.             iHandle: Handle;
  54.             s: Str255;
  55.     begin
  56.         GetPort(gOldPort);
  57.         GetIndString(s, compressingAlertStringsID, ord(compressing) + 1);
  58.         ParamText(s, '', '', '');
  59.         gAlert := GetNewDialog(compressingAlertDlogID, nil, WindowPtr(-1));
  60.         GetDItem(gAlert, progressItem, iType, iHandle, gProgressRect);
  61.         gProgress := 0;
  62.         gMaxProgress := gProgressRect.right - gProgressRect.left;
  63.         ShowWindow(gAlert);
  64.         DrawDialog(gAlert);
  65.         SetPort(gAlert);
  66.         FrameRect(gProgressRect);
  67.         ShowWatch;
  68.     end;
  69.  
  70. {$D+}
  71.     procedure SetProgress (numer, denom: longint);
  72.         var
  73.             r: Rect;
  74.     begin
  75.         gProgress := round((numer / denom) * gMaxProgress);
  76.         r := gProgressRect;
  77.         r.right := r.left + gProgress;
  78.         FillRect(r, black);
  79.     end;
  80.  
  81. {$D+}
  82.     procedure HideCompressingAlert;
  83.     begin
  84.         DisposeDialog(gAlert);
  85.         SetPort(gOldPort);
  86.     end;
  87.  
  88. {$D-}
  89.     procedure TransposePixels (src, dst: univ longint; width, height: integer);
  90.         var
  91.             p, q: longint;
  92.             row, col: integer;
  93.     begin
  94.         p := src;
  95.         for row := 0 to height - 1 do begin
  96.                 q := dst + row;
  97.                 for col := 0 to width - 1 do begin
  98.                         BytePtr(q)^[0] := BytePtr(p)^[0];
  99.                         p := p + 1;
  100.                         q := q + height;
  101.                     end;
  102.             end;
  103.     end;
  104.  
  105. {$D+}
  106.     function LZSS (src: univ BytesPtr; srcLen: longint): Handle;
  107.     begin
  108.         LZSS := LZSSX(0, nil, 0, src, srcLen, true);
  109.     end;
  110.  
  111. {$D+}
  112.     procedure FindMatchScrewUp;
  113.     begin
  114.         Panic('LZSSX: FindMatch', 'MatchLength and PMatchLength gave different results');
  115.     end;
  116.  
  117. {$D-}
  118.     function LZSSX (skip: longint; header: univ BytesPtr; headerLen: longint; data: univ BytesPtr; dataLen: longint; compressing: boolean): Handle;
  119.         const
  120.             maxMatch = 18;                            {Maximum match length we can encode}
  121.         var
  122.             src: BytesPtr;                                {source data}
  123.             srcLen: longint;                                {length of source data}
  124.             h: Handle;                                        {place to put compressed data}
  125.             dst: BytesPtr;                                {h^}
  126.             sp, dp: longint;                                {src and dst pointers}
  127.             flagPos: longint;                                {offset of current flags byte}
  128.             flagCount: integer;                            {number of flags in current flags byte}
  129.             index: array[0..255] of longint;    {byte -> offset of last matching byte}
  130.             chain: array[0..$FFF] of longint;    {offset -> offset of prev matching byte}
  131.             prog, progStep: longint;
  132.  
  133.     {Advance source pointer and update chains}
  134.  
  135.         procedure Advance (n: longint);
  136.             var
  137.                 byte: integer;
  138.         begin
  139.             prog := prog - n;
  140.             if prog <= 0 then begin
  141.                     SetProgress(sp, srcLen);
  142.                     prog := progStep;
  143.                 end;
  144.             if compressing then
  145.                 while n > 0 do begin
  146.                         byte := src^[sp];
  147.                         chain[BAND(sp, $FFF)] := index[byte];
  148.                         index[byte] := sp;
  149.                         sp := sp + 1;
  150.                         n := n - 1;
  151.                     end
  152.             else
  153.                 sp := sp + n;
  154.         end;
  155.  
  156.     {Store a byte of compressed data}
  157.  
  158.         procedure PutByte (x: integer);
  159.         begin
  160.             dst^[dp] := x;
  161.             dp := dp + 1;
  162.         end;
  163.  
  164.     {Store a word of compressed data, little-endian}
  165.  
  166.         procedure PutWord (x: integer);
  167.         begin
  168.             dst^[dp] := BAND(x, $FF);
  169.             dst^[dp + 1] := BSR(x, 8);
  170.             dp := dp + 2;
  171.         end;
  172.  
  173.     {Store a flag, making a new flags byte if necessary}
  174.  
  175.         procedure PutFlag (f: integer);
  176.         begin
  177.             if flagCount = 8 then begin
  178.                     flagPos := dp;
  179.                     PutByte(0);
  180.                     flagCount := 0;
  181.                 end;
  182.             dst^[flagPos] := dst^[flagPos] + BSL(f, flagCount);
  183.             flagCount := flagCount + 1;
  184.         end;
  185.  
  186.     {Find the number of bytes matching at pos1 and pos2}
  187.  
  188.         function MatchLength (pos1, pos2: longint): integer;
  189.             var
  190.                 pos0, maxPos: longint;
  191.         begin
  192.             pos0 := pos1;
  193.             maxPos := pos0 + maxMatch;
  194.             if maxPos > srcLen then
  195.                 maxPos := srcLen;
  196.             while (pos1 < maxPos) & (src^[pos1] = src^[pos2]) do begin
  197.                     pos1 := pos1 + 1;
  198.                     pos2 := pos2 + 1;
  199.                 end;
  200.             MatchLength := pos1 - pos0;
  201.         end;
  202.  
  203. {$IFC FALSE}
  204.         function MatchLength (addr1, maxAddr1, addr2: univ Ptr): integer;
  205.         inline
  206.             $245F,{00000000: 245F               MOVEA.L   (A7)+,A2}
  207.             $205F,{00000002: 205F               MOVEA.L   (A7)+,A0}
  208.             $225F,{00000004: 225F               MOVEA.L   (A7)+,A1}
  209.             $2009, {00000006: 2009               MOVE.L    A1,D0}
  210.             $6004,{00000008: 6004               BRA.S     *+$0006        ; 0000000E}
  211.             $B509,{0000000A: B509               CMPM.B    (A1)+,(A2)+}
  212.             $6606,{0000000C: 6606               BNE.S     *+$0008        ; 00000014}
  213.             $B1C9,{0000000E: B1C9               CMPA.L    A1,A0}
  214.             $66F8,{00000010: 66F8               BNE.S     *-$0006        ; 0000000A}
  215.             $6002,{00000012: 6002               BRA.S     *+$0004        ; 00000016}
  216.             $5389,{00000014: 5389               SUBQ.L    #$1,A1}
  217.             $93C0,{00000016: 93C0               SUBA.L    D0,A1}
  218.             $3E89;{00000018: 3E89               MOVE.W    A1,(A7)}
  219. {$ENDC}
  220.  
  221.     {Search back through the chains for the longest match}
  222.     {Return true if it is at least 3 bytes long}
  223.  
  224.         function FindMatch (var bestPos, bestLen: longint): boolean;
  225.             var
  226.                 pos, len: longint;                    {Offset and length of match being considered}
  227.         {max: longint;}
  228.                 window: longint;                    {Earliest offset at which a match is valid}
  229.         begin
  230.             window := sp - $1000;
  231.             if window < 0 then
  232.                 window := 0;
  233.             bestLen := 0;
  234.             pos := index[src^[sp]];
  235.             while (pos >= window) & (bestLen < maxMatch) do begin
  236.                     len := MatchLength(pos, sp);
  237.         {$IFC FALSE}
  238.                     max := pos + maxMatch;
  239.                     if max > srcLen then
  240.                         max := srcLen;
  241.                     len := MatchLength(@src^[pos], @src^[max], @src^[sp]);
  242.                     if (len <> plen) then
  243.                         FindMatchScrewUp;
  244.         {$ENDC}
  245.                     if len > bestLen then begin
  246.                             bestPos := pos;
  247.                             bestLen := len;
  248.                         end;
  249.                     pos := chain[BAND(pos, $FFF)];
  250.                 end;
  251.             FindMatch := bestLen >= 3;
  252.         end;
  253.  
  254.         procedure InitChains;
  255.             var
  256.                 i: integer;
  257.         begin
  258.             for i := 0 to 255 do
  259.                 index[i] := -1;
  260.             for i := 0 to $FFF do
  261.                 chain[i] := -1;
  262.         end;
  263.  
  264.     {Main loop}
  265.  
  266.         procedure Compress (block: BytesPtr; blockLen: longint);
  267.             var
  268.                 pos, len: longint;                            {position and length of match}
  269.         begin
  270.             InitChains;
  271.             src := block;
  272.             sp := 0;
  273.             srcLen := blockLen;
  274.             while sp < srcLen do begin
  275.                     if compressing & FindMatch(pos, len) then begin
  276.                             PutFlag(0);
  277.                             PutWord(BOR(BSL(len - 3, 12), $1000 - (sp - pos)));
  278.                             Advance(len);
  279.                         end
  280.                     else begin
  281.                             PutFlag(1);
  282.                             PutByte(src^[sp]);
  283.                             Advance(1);
  284.                         end;
  285.                 end;
  286.         end;
  287.  
  288. {$D+}
  289.     begin {LZSSX}
  290.         h := NewHandle(skip + headerLen + dataLen + (headerLen + dataLen + 7) div 8);
  291.         if h = nil then
  292.             DoAlert(outOfMemAlrtID)
  293.         else begin
  294.                 ShowCompressingAlert(compressing);
  295.                 progStep := dataLen div 200;
  296.                 prog := progStep;
  297.                 HLock(h);
  298.                 dst := BytesPtr(h^);
  299.                 dp := skip;
  300.                 flagCount := 8;
  301.                 if headerLen > 0 then
  302.                     Compress(header, headerLen);
  303.                 Compress(data, dataLen);
  304.                 SetHandleSize(h, dp);
  305. {writeln('Compressed ', srcLen : 1, ' to ', dp : 1, ' bytes (', 100.0 * dp / srcLen : 1 : 1, '%)');}
  306.                 HUnlock(h);
  307.                 HideCompressingAlert;
  308.             end;
  309.         LZSSX := h;
  310.     end;
  311.  
  312. {$D-}
  313.     procedure DLZSS (src, dst: univ BytesPtr; dstLen: longint);
  314.         var
  315.             sp, dp: longint;
  316.             flagCount: integer;
  317.             flags: integer;
  318.             item: integer;
  319.             copyEnd: longint;
  320.             pos: longint;
  321.     begin {DLZSS}
  322.         sp := 0;
  323.         dp := 0;
  324.         flagCount := 0;
  325.         while dp < dstLen do begin
  326.                 if flagCount = 0 then begin
  327.                         flags := src^[sp];
  328.                         sp := sp + 1;
  329.                         flagCount := 8;
  330.                     end;
  331.                 if odd(flags) then begin
  332.                         dst^[dp] := src^[sp];
  333.                         sp := sp + 1;
  334.                         dp := dp + 1;
  335.                     end
  336.                 else begin
  337.                         item := src^[sp] + BSL(src^[sp + 1], 8);
  338.                         sp := sp + 2;
  339.                         pos := dp - $1000 + BAND(item, $FFF);
  340.                         copyEnd := dp + 3 + BAND($F, BSR(item, 12));
  341.                         if copyEnd > dstLen then
  342.                             copyEnd := dstLen;
  343.                         while dp < copyEnd do begin
  344.                                 dst^[dp] := dst^[pos];
  345.                                 dp := dp + 1;
  346.                                 pos := pos + 1;
  347.                             end;
  348.                     end;
  349.                 flags := BSR(flags, 1);
  350.                 flagCount := flagCount - 1;
  351.             end;
  352.     end;
  353.  
  354. {$D-}
  355.     procedure DLZSSX (src, dst: univ BytesPtr; skip, dstLen: longint);
  356.         var
  357.             sp, dp: longint;
  358.             flagCount: integer;
  359.             flags: integer;
  360.             item: integer;
  361.             copyEnd: longint;
  362.             pos: longint;
  363.     begin {DLZSS}
  364.         sp := 0;
  365.         dp := 0;
  366.         flagCount := 0;
  367.         while dp < dstLen do begin
  368.                 if flagCount = 0 then begin
  369.                         flags := src^[sp];
  370.                         sp := sp + 1;
  371.                         flagCount := 8;
  372.                     end;
  373.                 if odd(flags) then begin
  374.                         if skip > 0 then
  375.                             skip := skip - 1
  376.                         else begin
  377.                                 dst^[dp] := src^[sp];
  378.                                 dp := dp + 1;
  379.                             end;
  380.                         sp := sp + 1;
  381.                     end
  382.                 else begin
  383.                         item := src^[sp] + BSL(src^[sp + 1], 8);
  384.                         sp := sp + 2;
  385.                         pos := dp - $1000 + BAND(item, $FFF);
  386.                         copyEnd := dp + 3 + BAND($F, BSR(item, 12));
  387.                         if copyEnd > dstLen then
  388.                             copyEnd := dstLen;
  389.                         while dp < copyEnd do begin
  390.                                 if skip > 0 then
  391.                                     skip := skip - 1
  392.                                 else begin
  393.                                         dst^[dp] := dst^[pos];
  394.                                         dp := dp + 1;
  395.                                     end;
  396.                                 pos := pos + 1;
  397.                             end;
  398.                     end;
  399.                 flags := BSR(flags, 1);
  400.                 flagCount := flagCount - 1;
  401.             end;
  402.     end;
  403. {$D+}
  404.  
  405. {$D-}
  406.     procedure UnpackObject (src: univ longint; srcSize: longint; dst: univ longint; dstWidth: integer);
  407.         var
  408.             numSpans: integer;
  409.             spanPtr, srcPtr, dstPtr: longint;
  410.             offset: integer;
  411.             x, y, y0, y1: integer;
  412.     begin
  413.         numSpans := WordPtr(src)^;
  414.         spanPtr := src + 2 + 2 * numSpans;
  415.         x := 0;
  416.         dst := dst + (dstWidth - numSpans) div 2;
  417.         while numSpans > 0 do begin
  418.                 while WordPtr(spanPtr)^ <> $FFFF do begin
  419.                         y0 := WordPtr(spanPtr)^ div 2;
  420.                         y1 := WordPtr(spanPtr + 2)^ div 2;
  421.                         offset := WordPtr(spanPtr + 4)^;
  422.                         spanPtr := spanPtr + 6;
  423.                         srcPtr := src + y0 + offset; {This is really screwy!}
  424.                         dstPtr := dst + x + y0 * dstWidth;
  425.                         for y := y0 to y1 - 1 do begin
  426.                                 BytePtr(dstPtr)^[0] := BytePtr(srcPtr)^[0];
  427.                                 srcPtr := srcPtr + 1;
  428.                                 dstPtr := dstPtr + dstWidth;
  429.                             end;
  430.                     end;
  431.                 spanPtr := spanPtr + 2;
  432.                 x := x + 1;
  433.                 numSpans := numSpans - 1;
  434.             end;
  435.     end;
  436.  
  437. {$D-}
  438.     function PackObject (src: univ BytesPtr; width, height: integer): Handle;
  439.         type
  440.             WordsHandle = ^WordsPtr;
  441.             WordsPtr = ^WordsArray;
  442.             WordsArray = array[0..32767] of integer;
  443.         var
  444.             spans: WordsHandle;
  445.             s, s0, s1, t, i, p, q: longint;
  446.             x, x0, x1, y, y0, y1, offset: integer;
  447.             spanbase, pixbase, pixels: longint;
  448.             buffer: Handle;
  449.             bufwords: WordsPtr;
  450.             bufbytes: BytesPtr;
  451.     begin
  452.         spans := WordsHandle(NewHandle(sizeof(WordsArray)));
  453.         s := 0;
  454.         pixels := 0;
  455.         for x := 0 to width - 1 do begin
  456.                 p := x;
  457.                 y := 0;
  458.                 while (y < height) do begin
  459.                         while (y < height) & (src^[p] = 0) do begin
  460.                                 y := y + 1;
  461.                                 p := p + width;
  462.                             end;
  463.                         y0 := y;
  464.                         offset := p;
  465.                         while (y < height) & (src^[p] <> 0) do begin
  466.                                 y := y + 1;
  467.                                 p := p + width;
  468.                             end;
  469.                         y1 := y;
  470.                         if (y0 < y1) then begin
  471.                                 spans^^[s] := 2 * y0;
  472.                                 spans^^[s + 1] := 2 * y1;
  473.                                 spans^^[s + 2] := offset;
  474.                                 s := s + 3;
  475.                                 pixels := pixels + (y1 - y0);
  476.                             end;
  477.                     end;
  478.                 spans^^[s] := -1;
  479.                 s := s + 1;
  480.             end;
  481.         x0 := 0;
  482.         x1 := width;
  483.         s0 := 0;
  484.         s1 := s;
  485.         while (s0 < s1) & (spans^^[s0] = -1) & (s1 > 0) & ((s1 < 2) | (spans^^[s1 - 2] = -1)) do begin
  486.                 s0 := s0 + 1;
  487.                 x0 := x0 + 1;
  488.                 s1 := s1 - 1;
  489.                 x1 := x1 - 1;
  490.             end;
  491.         spanbase := 1 + (x1 - x0);
  492.         pixbase := 2 * (spanbase + (s1 - s0));
  493.         buffer := NewHandle(pixbase + pixels);
  494.         bufwords := WordsPtr(buffer^);
  495.         bufbytes := BytesPtr(buffer^);
  496.         bufwords^[0] := x1 - x0;
  497.         i := 1;
  498.         s := s0;
  499.         t := spanbase;
  500.         q := pixbase;
  501.         while s < s1 do begin
  502.                 bufwords^[i] := 2 * t;
  503.                 i := i + 1;
  504.                 while spans^^[s] <> -1 do begin
  505.                         y0 := spans^^[s] div 2;
  506.                         y1 := spans^^[s + 1] div 2;
  507.                         p := spans^^[s + 2];
  508.                         s := s + 3;
  509.                         bufwords^[t] := 2 * y0;
  510.                         bufwords^[t + 1] := 2 * y1;
  511.                         bufwords^[t + 2] := q - y0;
  512.                         t := t + 3;
  513.                         for y := y0 to y1 - 1 do begin
  514.                                 bufbytes^[q] := src^[p];
  515.                                 p := p + width;
  516.                                 q := q + 1;
  517.                             end;
  518.                     end;
  519.                 bufwords^[t] := -1;
  520.                 s := s + 1;
  521.                 t := t + 1;
  522.             end;
  523.         DisposHandle(Handle(spans));
  524.         PackObject := Handle(buffer);
  525.     end;
  526.  
  527. end.